Shareware Grab Bag/Shareware Grab Bag.iso/090/td2a.arc/TDA.LIB

Text File | 1985-07-18 | 6KB | 206 lines

{ Turbodraw library }

type
    stype = string[20];
    td_str80 = string[80]; {L.P.}

const
    ctlh = ^H;   { Backspace }
    ctlm = ^M;   {  Return   }


function getnum(p,q:integer):stype;    { 12/19/84 }

{ Getnum allows entry of a number of Scale P and Precision Q }
{ The operator is not allowed to enter a number with greater }
{ precision and/or scale.  Character delete using the back-  }
{ space key can be used.                                     }

var
    i      : integer;
    number : stype;       { Input buffer }
    digit  : char;
    frac   : integer;
    dp     : boolean;

begin
    I:=1;
    Dp:=false;
    Frac:=0;
    Digit:=' ';
    Number:=' ';

    while Digit <> ctlm do
        begin          { don't exit until a CR is entered }
        read(kbd,digit);
        write(digit);
        If Digit=ctlh Then { backspace }
            If I > 1 Then
                begin
                I:=I-1;
                If Dp=TRUE Then Frac:=Frac-1;
                If Copy(Number,I,1)='.' Then
                    begin     { special handling for decimal point }
                    Dp:=FALSE;
                    Frac:=0   { just to make sure its at zero    }
                End;
                number:=copy(number,1,i-1)+' '+copy(number,i+1,20);
                write(' ' + ctlh)     { Delete character on screen }
            End
            Else { If I>1 }
                write(' ');  { put cursor back }
            If Digit='-' Then
                If I = 1 Then
                    begin
                    number:=copy(number,1,i-1)+digit+copy(number,i+1,20);
                    I:=I+1;
                End
                Else
                    Digit:=' ';
            if digit in ['0'..'9'] then
                begin;
                If Dp=TRUE Then { we are past decimal point    }
                    begin
                    if (I=P+2) or (Frac = q) Then
                      BEGIN {L.P.}
                        write(ctlh + ' ' + ctlh);  { At full prec. }
                        write(^G); {Bell} {L.P.}
                      END {L.P.}
                    Else
                        begin
                        number:=copy(number,1,i-1)+digit+copy(number,i+1,20);
                        Frac:=Frac+1;
                        I:=I+1;
                    End
                End
                Else    { If DP }
                If I=P-Q+1 Then   { allow only a '.' }
                  BEGIN {L.P.}
                    write(ctlh + ' ' + ctlh);
                    WRITE(^G); {L.P.}
                  END {L.P.}
                Else
                    begin
                    number:=copy(number,1,i-1)+digit+copy(number,i+1,20);
                    I:=I+1;
                End;

            End    { If verify }
            Else
            If Digit='.' Then
                If Dp=FALSE Then { only one decimal per number }
                    begin
                    number:=copy(number,1,i-1)+'.'+copy(number,i+1,20);
                    I:=I+1;
                    Dp:=TRUE;
                End
                Else
                Digit:=' ';  { eliminate extra decimal point }
                if not (digit in ['-','0'..'9','.',ctlh,ctlm]) then
                    write(ctlh + ' ' + ctlh);
            End;  { Do While }

           getnum:=number;
       end;

function getreal(len,scale : integer) : real;

{ GETREAL returns a number of max length LEN }
{ and max scale SCALE                        }

var
   i,j,temp,sign  : integer;
   result         : real;
   digit          : char;
   num            : stype;
   code           : integer;

begin
   num:=getnum(len,scale);
   i:=length(num);
   j:=1;
   sign:=1;
   while i > 0 do
       begin
       digit:=copy(num,i,1);
       i:=i-1;
       case digit of
           '0'..'9' : begin
                         val(digit,temp,code);
                         result:=result+(temp*j);
                         j:=j*10;
                      end;
           '-'      : sign:=-1;
           '.'      : begin
                         result:=result/j;
                         j:=1;
                      end;
        end;
    end;
    getreal:=result*sign;
end;

function getint(len : integer) : integer;

{ GETINT returns a number of max length LEN and }
{ a scale of zero ( integer )                   }

var
   result,code : integer;
   num         : stype;

begin
   val(getnum(len,0),result,code);
   getint:=result;
end;   { of Turbodraw Library }

{ This entire function by L.P.}
function getstr(w:integer):td_str80; {7/18/85}

{ Getstr allows entry of a string of width w.  The operator is not allowed }
{ enter a string with greater width.  Character delete using the backspace }
{ key can be used. }

var
  instr: td_str80;
  i: INTEGER;
  c: CHAR;

BEGIN
  i := 1;
  c := CHR(0);
  instr := '';

  { The length of the starting string can be w only to allow for a backspace }
  { after the last character. }
  WHILE c <> ctlm DO
    BEGIN
      READ(KBD, c);
      CASE c of
        ctlh: {backspace}
          IF i > 1 THEN
            BEGIN
              i := i - 1;
              DELETE(instr, i, 1);
              write(ctlh + ' ' + ctlh); {Delete character on screen}
            END; {backspace for i > 1} {Do nothing for i = 1}
        ctlm: { Return }
          ;
        ELSE
          IF LENGTH(instr) < w
            THEN
              BEGIN
                WRITE(c);
                INSERT(c, instr, i);
                i := i + 1;
              END
            ELSE
              WRITE(^G); {Bell} {End not a backspace or carriage return}
      END; { case}
    END; {WHILE}
  getstr := instr;

END; {getstr}